perm filename SHFTX.F4[MSS,LCS] blob
sn#269271 filedate 1977-03-12 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 DIMENSION J(15)
C00004 ENDMK
Cā;
DIMENSION J(15)
4 TYPE 1
1 FORMAT(' TYPE '$)
ACCEPT 2,J
2 FORMAT(15A1)
CALL NAMEXT(J,K,L)
TYPE 3,K,L
3 FORMAT(1XA5,1X,A5)
GO TO 4
END
SUBROUTINE NAMEXT(JA,NAME,IEXT)
C PUSHES 1 TO 5 A1 CHARS IN A SINGLE A5 WORD.
DIMENSION JA(10),JB(5)
DATA KK/128/,LL/"377777777777/,JJ/"2000000000/
DATA MM/"774000000000/, JB(4)/' '/,JB(5)/' '/
JXX=0
NAME=' '
DO 1 K=1,4
1 IF(JA(K).EQ.' '.AND.JA(K+1).NE.' ')GO TO 2
GO TO 12
2 PAUSE 'NO BLANKS ALLOWED!!!'
RETURN
12 DO 20 K=1,6
IF(JA(K).NE.'.')GO TO 20
JXX=-1
J2=K+1
JA(K)=' '
DO 21 JX=1,4
JB(JX)=JA(J2)
JA(J2)=' '
21 J2=J2+1
GO TO 50
20 CONTINUE
50 JX=6
DO 10 K=5,1,-1
10 IF(JA(K).EQ.' ')JX=K
IF(JX.GT.2)GO TO 51
N=JA(1)
GO TO 52
51 IA=JA(1)
IF(IA)IA=MM.AND.JA(1)
J2=2
7 IB=JA(J2)
IBX=IB
IF(IBX)IB=MM.AND.JA(J2)
11 K=IB.AND.LL
4 K=K/KK
5 IF(IBX)K=K.OR.JJ
C RESTORES LEFT HAND BIT (101 ETC.)
IF(J2.EQ.2)GO TO 3
DO 8 JL=1,J2-2
8 K=K/KK
3 N=IA.OR.K
IA=N
J2=J2+1
IF(J2.NE.JX)GO TO 7
52 IF(NAME.NE.' ')GO TO 23
NAME=N
IF(JXX.EQ.0)RETURN
DO 24 K=1,5
24 JA(K)=JB(K)
GO TO 50
23 IEXT=N
END